perm filename RHYTH.F4[NEW,LCS]23 blob
sn#385166 filedate 1978-09-29 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 C***** SUBRS RHYTH, NOTNUM, DOTS ********
C00020 ENDMK
C⊗;
C***** SUBRS RHYTH, NOTNUM, DOTS ********
SUBROUTINE RHYTH
COMMON/RINP/R(10,85),POSNT(0/99)
1 /RMOD/RMODE2,SET4,IBEAM,NOSET,STEM,STUP,NTC,PS2,
1 RA,RDD,ITB,POSB /PTR/KWDS(1) /FRMT/FQZ(3),IREAD
1 /XRN/RN(1) /IDEV/IDEV
1 /SCM/V(78),I,LCNT,STAFF,LIST(200),REND
1 /SCX/JALPHA(30),JX,JXX,JZ,IRHY,JD,KA,KB,IZ
1 /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,DBST,
1 NFLG,KXX,ISEMI,IQT,VX(50),IAMP,K,KN,M,MODE,IBLA
1 /ALF/INP(59),NX,NOTE,JSET,KZ,KX,AVGPOS,RLPOS,RLP2,
1 AVP2,ZX,RE,ZZ,RD,RSTX
C SEE ALSO FILLMS, SETLET AND SETUP RE. /FLM/
DIMENSION RPOS(2,100)
COMMON R2,JH,CENTR,J2,R3,R4,R5,RJQ(17),J3,JQ(19)
1 /DPY/ST(4000),MEDIT,GO /LIMIT/LIMIT,ITEM,NL,NO,NONO
1 /POS/POS1,POS2 /STF/RSTFAC(0/7),RSTJ2
EQUIVALENCE (VX(1),X),(VX(2),Y),(VX(7),Z),(RPOS,ST(3400))
1,(VX(3),AB),(VX(4),T),(VX(5),RB),(VX(6),X2)
1,(VX(8),C),(VX(9),S),(VX(10),X3)
CCC DATA FIB/.75/
C FIB IS FOR PSUEDO-FIBONACCI SPACING
RSTJ3=RSTFAC(IFIX(STAFF))
POSNT(0)=-1
POSNT(1)=-1
C IN CASE 1ST NOTE IS AT POS. ZERO
NX=-1
JX=0
T=0
Y=0
NOTE=0
ICNTPT=-1
NOSET=0
JSET=0
C STUP IS NEG. IF SETUP IS NOT READY
IF(STUP)GO TO 341
IF(SET4.NE.STAFF)GO TO 70
NOSET=-1
C TO ADD MORE NOTES ON SETUP LINE. WIPES OUT P9 AT END OF SCMSS.
GO TO 270
70 DO 370 K=1,ITEM-IZ-1
C LOOKS ONLY AT THINGS BEFORE CURRENT INPUT.
J=KWDS(K)
IF(RN(J+1).GT.2)GO TO 370
IF(RN(J+2).EQ.STAFF)GO TO 270
370 CONTINUE
GO TO 170
270 ICNTPT=0
C THIS WILL CAUSE NOTES ADDED TO LINE TO HAVE NO RHYTH VAL IN P9
170 KZ=1
POS2=PS2
C GETS LAST ↑↑ POS. FROM SETUP
JSET=-1
C NEXT NUM.(100) IS LIMIT FOR STF.4 (CAN BE UP TO 300-SEE /FLM/)
DO 9 KX=1,100
9 IF(RPOS(2,KX).GE.0)GO TO 10
10 AVGPOS=RPOS(1,KX)
RLPOS=AVGPOS
344 KX=KX+1
IF(RPOS(2,KX).EQ.-3)GO TO 344
C**** IGNORES CLEFS (BUT NOT BARS) IN AUTOMATIC SPACING ***** 10/76
RLP2=RPOS(1,KX)
343 AVP2=RPOS(2,KX)-.001
IF(AVP2.GT.0)GO TO 341
KX=KX+1
GO TO 343
C AVERAGED AND REAL POSITIONS FROM 'SETUP'
C NEXT FOR NON-SETUP
341 DO 34 K=1,IRHY
CALL DOTS(VAL,RH,K,DOT)
C VAL=RHYTH. VALUE (QTR=1), RH=DENOMINATOR (QTR=4), DOT=NUM OF DOTS
C 88TH NOTES ARE TAKEN AS GRACE NOTES. THEN BECOME 32NDS.
IF(RH.NE.88)GO TO 345
IF(JSET)GO TO 34
C GRACE NOTES SKIPPED IN AUTOMATIC SETUP
VAL=.1
CFIB345 IF(STUP.LT.-1)VAL=PFIBX(VAL)
345 IF(STUP.LT.-1)VAL=14.0*EXP(ALOG(VAL)*0.5849624)
C THIS IS EXP((ALOG(A)/ALOG(2.0))*ALOG(1.5)) NOT FIBBONACI (1.618)
CCC345 IF(STUP.LT.-1)Z=Z+(.125-Z)*FIB
C STUP CAN BE SET TO .LT.-1 IN NOTBMS FOR PSUEDO-FIBONACCI SPACE
Y=Y+VAL
34 CONTINUE
C Y=TOTAL TIME
C A SAFEGUARD
C SAVES POS1 FOR POSITIONING MF, CRESC. ETC.
NTC=0
C THE WORD COUNT FOR REAL NOTES.
IF(JSET)GO TO 3421
IF(POS1.LT.POS2)POSX=POS1
C SAVES IT FOR BACKUP
IF(POS1.GE.POS2)POS1=POSX
Z=POS2-POS1
ZX=Z
342 DO 1 K=1,IZ
X=R(1,K)
IF(X.LT.3.)GO TO 1
C JUMP IF NOTE OR REST
IF(X.NE.17.)GO TO 8
C JUMP IF NOT A KEY SIG.
RA=AMOD(R(5,K),100.0)
C 100+KEY SIG NUM = SIG MADE UP OF NATURALS.
RA=2.+ABS(RA)*2.0
GO TO 6
8 IF(X.NE.4.)GO TO 81
C NEXT IS FOR BAR LINES
RA=3
J=K+1
RE=R(1,J)
IF(RE.EQ.3.)RA=1.5
C A CLEF
IF(RE.EQ.18)RA=2.5
C A METER
IF(RE.NE.1)GO TO 83
IF(AMOD(R(5,J),10.).NE.0)RA=4.5
C FINDS ACCI ON NEXT NOTE.
83 IF(K.EQ.IZ)RA=0
C END OF STAFF
GO TO 6
82 RA=5
CGHB82 RA=6
GO TO 83
81 IF(X.EQ.18)GO TO 82
RA=6.
IF(K.LT.3)RA=8.
CGHB RA=7.
C FOR CLEFS
CGHB IF(K.LT.3)RA=9.
C THE FIRST CLEF IS NOT MINI
6 RA=RA*RSTJ3
C SO SPACE WILL DEPEND ON SIZE OF STAFF
Z=Z-RA
R(8,K)=RA
C STORES SPACE NUM THAT MUST BE GIVEN BACK
1 CONTINUE
C SUBTRACTS SPACE FOR CLEF OR BAR. WILL ADD BOTH LATER.
C POS1 AND Z ARE FOR RHYTHMIC SPACING
C SPACE FOR NON-NOTES
3421 K=0
IF(ABS(Y-RA).LE..001)GO TO 3
IF(JSET)CALL MISMCH(RA,Y)
C TYPES MISMATCH MESSAGE
C LOOP TO END
3 K=K+1
C K IS COUNTER
T=0
CXX R(7,K)=0
RE=R(1,K)
IF(RE.LE.2.)GO TO 2
RD=R(8,K)
R(8,K)=0
IF(JSET)GO TO 71
7 IF(K.EQ.IZ)POS1=POS2
IF(R(1,K-1).GT.2.)GO TO 73
IF(K.EQ.1)GO TO 73
IF(RE.EQ.4.)GO TO 73
Z=Z+RD/3.
C RETURNS 1/3 OF THE SPACE IF PREV. ITEM IS NOTE OR REST
POS1=POS1-RD/3
C THIS CAN RESULT IN OVERLAP WHICH MUST BE EDITED OUT.!!
73 R(3,K)=POS1
72 POS1=POS1+RD
C ABOVE SECTION LEAVES ROOM FOR CLEF OR BAR
GO TO 337
C 40??? 50???? WHY NOT 100?
71 DO 74 J=KZ,80
74 IF(RE.EQ.-RPOS(2,J))GO TO 75
POS=R(3,K-1)+4
GO TO 76
75 POS=RPOS(1,J)
KZ=J+1
C FOUND SAME TYPE OF ITEM.
76 R(3,K)=POS
GO TO 337
2 JX=JX+1
21 CALL DOTS(VAL,RH,JX,DOT)
V(JX)=VAL
IF(RE.NE.2)GO TO 121
V(JX)=-VAL
C SHOWS RESTS IN AUTO. BEAM SECTION.(ASSUMES REST WAS A + NUMB.)
R(7,K)=VAL
GO TO 210
121 IF(R(8,K).GE.-1.)R(9,K)=VAL
C STORES RHYTH VALUE FOR LATER USE IN PART EXTRACTOR IF NOT CHORD NOTE.
CCC IF(AB.GT..05)GO TO 210
IF(RH.NE.88.)GO TO 210
R(3,K)=-1.
R(4,K)=R(4,K)+100.
C WILL THIS BE OK WITH NOTES BELOW B3 (I.E. NEG POSITIONS.
R(7,K)=1
C FOUND A GRACE NOTE (88TH NOTE)
RB=4./88.
R(9,K)=RB
JZ=1
IF(STEM.GE.0)GO TO 1211
IF(R(9,K-1).EQ.RB)GO TO 1211
4211 IF(V(JX+1).EQ.88..AND.R(1,K+1).EQ.1)GO TO 1211
C STEM WILL BE UP UNLESS PRESET OR TWO OR MORE IN A ROW.
IF(R(5,K).GE.20.)R(5,K)=R(5,K)-10.
C NOW STEM IS UP
1211 IF(R(8,K+JZ).GE.0)GO TO 211
J=K+JZ
C GRACE NOTE CHORDS
R(3,J)=-1
C FOR AUTO-SPACING AT 337
R(4,J)=R(4,J)+100.
C MAKE IT A MINI-NOTE
R(8,K)=1000.+ABS(R(4,K)-R(4,J))
C EXTEND THE STEM
JZ=JZ+1
C FOR MORE CHORD NOTES. SHOULD I CHECK FOR END (IZ)?
GO TO 1211
C ** NOT NOW ***TURNS STEM OVER. UNLESS STEM DIRECTIONS WERE FIXED.(SU/SD/)
211 IF(JZ.LE.1)R(8,K)=1000
2211 IF(JSET.GE.0)GO TO 3211
K=K+JZ-1
C POS WILL BE SET AT 336
NTC=NTC+1
C UPDATE THE COUNTER FOR IMPORTANT POSITIONS. POSNT SET AT 336
POSNT(NTC)=-1
GO TO 337
3211 VAL=.1
C IT USED TO JUMP. NOW MAKES SPACE FOR GRACE NOTES AS 32NDS.
210 RB=0
C FOR AUTOMATIC SETUP
JZ=K
C JZ WILL BE USED NEAR END
CC3634 IF(AMOD(AB,.1875).EQ.0)GO TO 122
CC T=IDOT*10
C IDOT IS NUM OF DOTS
IF(RE.EQ.2.)GO TO 35
IF(RH.EQ.88)GO TO 22
CXX T=0
IF(RH.LT.8)GO TO 522
CC IF(R(5,K).LT.10)GO TO 422
C DON'T ADD TAILS TO STEMLESS NOTE. (IT CONFUSES 'BEAMS')
T=IFIX(ALOG(RH)/0.6931472+.001)-2.0
C RH=8=1 TAIL, 16=2TAILS, ETC. THE NUM. (8,16) IS RESULT OF 2 TO THE NTH.
522 RB=0
IF(DOT.EQ.0)GO TO 422
IF(R(6,K).GE.20)RB=100
C TO SHIFT DOT DOWN 2 STEPS
422 R(7,K)=T+RB+DOT
T=0
cc422 R(7,K)=T+IDOT
C PUTS ONE OR MORE DOTS
CC GO TO 36
GO TO 22
35 IF(R(6,K).GE.0)GO TO 135
R(6,K)=-1
GO TO 22
C ADDS DOT TO REST. (IF R6 IS -2. = INVIS. REST. CHANGE IT TO -1)
135 R(6,K)=DOT/10.
CC35 R(6,K)=T/10.
CC36 RB=VAL/3.
CC IF(T.NE.1)RB=(4*VAL)/7
C TO KEEP TAIL ON DOTTED NOTE
22 POS=POS1
IF(R(6,K).GE.30)R(6,K)=R(6,K)-30
C 30 NEEDED FOR SOME CASES WITH DOTS ON CHORDS.
IF(JSET.EQ.0)GO TO 220
C NEXT IS FOR SETUP
222 IF(NOTE)GO TO 223
C FIRST TIME A NOTE IS FOUND.
NOTE=-1
POS1=RLPOS
Z=POS2-POS1
C RESETS SPACE AVAILABLE, ZZ IS SPACE FOR NON-NOTES
223 IF(POS1.LT.AVP2)GO TO 221
224 KX=KX+1
C???? OCT, 73 IF(NX.EQ.0)GO TO 225
L=KX
1228 IF(RPOS(2,L).NE.-3)GO TO 228
L=L+1
C IGNORE CLEFS (BUT NOT BARS) ********* 10/76
GO TO 1228
228 IF(NX)RLP2=RPOS(1,L)
NX=-1
225 IF(RPOS(2,KX-1))GO TO 227
RLPOS=RPOS(1,KX-1)
AVGPOS=AVP2
227 AVP2=RPOS(2,KX)-.001
IF(AVP2.GT.0)GO TO 223
C 0 IN RPOS=POS. OF NON-NOTE
CC****** WHY NEEDED?? 6/74 *** IF(RLP2.GE.POS1)NX=0
NX=0
CC*****↑↑↑↑ CHANGED FROM ABOVE *** 6/74
GO TO 224
221 POS=(POS1-AVGPOS)*(RLP2-RLPOS)/(AVP2-AVGPOS)+RLPOS
220 R(3,K)=POS
4634 IF(RE.NE.1)GO TO 44
IF(POS.EQ.POSNT(NTC))GO TO 2634
C SKIPS OTHER CHORD NOTES.
NTC=NTC+1
POSNT(NTC)=POS
C SAVES IT FOR NUMBS ABOVE NOTES, ETC.
2634 IF(RH.LT.4)GO TO 4
C JUMP IF DENOM. IS LESS THAN 4. I.E. 1/2 NOTE ETC.
44 L=K+1
IF(R(8,L).GE.0)GO TO 1634
IF(R(1,L).NE.1.)GO TO 1634
C JUMP IF NOT DOUBLE STOP
C DELETES STEM FROM WHOLE NOTE CHORD (NOW DONE IN NOTWRT IF P7=1)
R(3,L)=R(3,K)
K=L
CC R(8,K)=0
GO TO 522
C LOOPS BACK TO PICK UP MORE CHORD NOTES
C 'WHITENS' HALF, WHOLE AND TRIPLET HALF NOTES.
4 RA=-R(6,K)
IF(RA.EQ.0)RA=-1
IF(RH.GE.2.)GO TO 144
R(5,K)=AMOD(R(5,K),10.0)
C TAKES STEM INFO OFF ANYTHING LONGER THAN 1/2 NOTES -- FOR SLUR ROUTINE.
RP=1
IF(RH.LE..5)RP=2
R(7,K)=R(7,K)+RP
C +1=WHOLE NOTE WILL PRINT +2=DBL WHL NT.
CC NOT NEEDED BECAUSE OF ABOVE. RA=-2.
144 R(6,K)=RA
GO TO 44
1634 T=POS1
RP=VAL
CFIB IF(STUP.LT.-1)RP=PFIBX(VAL)
IF(STUP.LT.-1)RP=14.0*EXP(ALOG(RP)*0.5849624)
C THIS IS EXP((ALOG(A)/ALOG(2.0))*ALOG(1.5)) NOT FIBBONACI (1.618)
CCC IF(STUP.LT.-1)RP=AB+(.125-AB)*FIB
C FOR PSUEDO-FIB. SPACING
POS1=RP/Y*Z+POS1
535 IF(R(1,JZ).EQ.1.)GO TO 337
RA=R(4,JZ)
C SETS REST
IF(R(8,JZ).NE.0.1)GO TO 537
T=-4
C***** R(8,JZ)=-2
C -2 CENTERS THE SIGN UNDER THE RIGHT CONDITIONS
GO TO 536
CC537 IF(VAL.LT.2)GO TO 538
CC T=-1
CC IF(RH.LT.2)T=-2
CC IF(RH.LT.1)T=-3
C -1=HLF RST, -2=WHOLE, -3=DBL WHL RST, -4=REPEAT BAR SIGN(./.)
CC GO TO 536
537 T=IFIX(ALOG(RH)/0.6931472+.001)-2.
536 R(5,JZ)=T
CCC GO TO 337
C******* 4/74 NEW WAY TO FIND TAILS
C OMITS RESTS (REALLY???)
CCC334 R(7,JZ)=T+R(7,JZ)
337 IF(K.LT.IZ)GO TO 3
CXXXXXXXX M=NTC+1 XXXXXXXXX 9/28/78
C********* WAS M=NTC ******* 4/14/78
M=NTC
DO 335 K=IZ,1,-1
IF(R(3,K).GE.0)GO TO 335
IF(K.NE.IZ)GO TO 336
R(3,K)=POS2-4.
GO TO 335
336 N=K-1
1336 RA=R(3,N)
IF(RA.GT.0)GO TO 2336
N=N-1
IF(N.GT.0)GO TO 1336
C GO BACK (IF MORE GRACE NOTES.) TO FIND PREVIOUS BIG NOTE.
2336 T=R(3,K+1)
RB=T-RA
RA=3
IF(RB.LE.4)RA=RB/2.
C IF SPACE IS SMALL USE 1/3 OF IT.
RB=T-RA
C NEXT FOR GRACE NOTE CHORDS
IF(R(8,K+1).GE.0)GO TO 1335
RB=T
CC RB=R(3,K+1)
CXXXX M=M+1
1335 R(3,K)=RB
POSNT(M)=RB
335 IF(R(8,K).GE.0.AND.R(1,K).EQ.1)M=M-1
C COUNT ONLY NOTES - BUT NOT NON-RHYTH CHORD NOTES.
K=0
45 K=K+1
C NEXT IS TO ARRANGE DOTS.
IF(R(7,K).LT.10)GO TO 451
RA=R(3,K)
DO 452 M=K+1,IZ
IF(R(3,M).NE.RA)GO TO 453
C JUMP IF NOT CHORD NOTE.
T=R(7,M)
RB=R(4,M)
IF(T.LT.100.)GO TO 452
C JUMP IF NOTE IS NOT ON LEFT SIDE OF UPWARD STEM
IF(RB-R(4,M-1).NE.2)GO TO 452
IF(AMOD(RB,2.).NE.0)R(7,M)=AMOD(T,10.)
C TAKES AWAY DOT IN CERTAIN CASES TO AVOID CONFUSION.
452 CONTINUE
453 K=M-1
451 IF(K.LT.IZ)GO TO 45
IF(ICNTPT)GO TO 13
DO 113 K=1,IZ
RA=R(1,K)
IF(RA.GT.2)GO TO 113
C THIS ZEROS RHYTH PARAM IF NOTES WERE ALREADY ON THIS LINE.
J=9
IF(RA.EQ.2)J=7
R(J,K)=0
113 CONTINUE
13 N=IZ
NTC=NTC+1
POSNT(NTC)=200
POSNT(0)=0
IF(IREAD.GE.0.AND.IDEV.EQ.5)CALL NOTNUM
END
SUBROUTINE NOTNUM
CC DIMENSION ISU(390)
COMMON R2,JH,CENTR,J2,R3,R4,R5,RJQ(17),J3,J4,J5,JQ(17)
1 /RINP/R(10,85),POSNT(0/99)
1 /RMOD/RMODE2,SET4,IBEAM,NOSET,STEM,STUP,NTC,PS2
1 /SCM/V(78),I,LCNT,STAFF,LIST(200),REND
1 /POSI/STFF(0/7),JJ2,POSQ /DPY/ST(4000),MEDIT,GO
CALL DPYSET(3,ST(3600),390)
CALL DPYBRT(6)
J2=STAFF
POSQ=STFF(J2)
J5=1
R4=20
C R5=0=1 STANDARD SIZE IS USED.
DO 131 K=1,NTC-1
R3=RHORZ(POSNT(K))
CALL PNUM
C GOES TO DRAW A NUMBER OVER A NOTE
J5=J5+1
IF(J5.EQ.10)J5=0
131 CONTINUE
132 CALL DPYOUT(3)
CALL SETPOG(1)
END
SUBROUTINE DOTS(VAL,RH,K,DOT)
COMMON/SCM/V(1)
C FINDS DOTS (1000S), GET RHYTH. AND RHYTHMIC VALUE (QTR=1)
RH=V(K)
IF(RH.EQ.0)RH=88.
VAL=4/RH
J=RH/1000.
DOT=J*10
IF(J.EQ.0)RETURN
RH=RH-J*1000
VAL=4./RH
Z=VAL
1 Z=Z/2
VAL=VAL+Z
J=J-1
IF(J.GT.0)GO TO 1
END